plot_ly(
data = led,
x = ~ `Tuberculosis Incidence`,
y = ~ `Tuberculosis treatment`,
color = ~ continent,
text = ~Country,
hoverinfo = "text",
type = "scatter") %>%
layout(
title = 'Tuberculosis incidence and treatment ratio',
yaxis = list(title = 'Tuberculosis treatment'),
xaxis = list(title = 'Tuberculosis incidence')
)
stat.test1 <- led %>% filter(continent %in% c("Africa", "Americas")) %>%
t_test(`Life expectancy` ~ continent)
stat.test1
## # A tibble: 1 × 7
## statistic t_df p_value alternative estimate lower_ci upper_ci
## <dbl> <dbl> <dbl> <chr> <dbl> <dbl> <dbl>
## 1 -12.3 85.8 1.31e-20 two.sided -12.5 -14.6 -10.5
ggboxplot(
led[continent %in% c("Africa", "Americas"),],
x = "continent", y = "Life expectancy",
ylab = "Life expectancy", xlab = "Continent",
add = "jitter",
color = "continent"
) +
ggtitle("Comparison of life expectancy in Africa and America, t-test") +
labs(subtitle = paste0("statistic = ", stat.test1$statistic, ", p-value = ", stat.test1$p_value)) +
theme(plot.title = element_text(color = "blue4"), legend.position = "none")
led_c <- led %>% select(where(is.numeric)) %>% select(!Year)
corled <- cor(led_c)
corrplot(corled, method = 'color', type = "lower", diag = FALSE,
addCoef.col = "grey30",
cl.pos = "b",
tl.col = "grey10",
col = COL2('RdBu', 10),
tl.cex = 1, cl.cex = 1,
number.cex = 0.8,
title = "\n\n\n\nCorrelation analysis of numeric parameters of life expectancy data",
cex.main = 2)
corled %>% rplot() +
theme_dark() +
theme(
axis.text.x = element_text(size = 16, angle = 90),
axis.text.y = element_text(size = 16),
legend.key.size = unit(16, "pt"),
plot.title = element_text(size = 25)) +
ggtitle("Correlation analysis of numeric parameters of life expectancy data")
ggpairs(led_c ,
title = 'Correlation analysis of numeric parameters of life expectancy',
progress = F) +
theme_minimal() +
scale_fill_manual(values = c('blue4')) +
scale_colour_manual(values = c('blue4')) -> g
g
led_c_scaled <- scale(led_c)
led_c_dist <- dist(led_c_scaled,
method = "euclidean"
)
led_c_hc <- hclust(d = led_c_dist,
method = "ward.D2")
fviz_dend(led_c_hc,
cex = 0.1)
pheatmap(led_c_scaled,
show_rownames = FALSE,
clustering_distance_rows = led_c_dist,
clustering_method = "ward.D2",
cutree_rows = 7,
cutree_cols = length(colnames(led_c_scaled)),
angle_col = 45,
main = "Dendrograms for clustering rows and columns with heatmap")
По результатам кластеризации с разделением наблюдений по отклонению от среднего можно отметить группу низких значений для объема вакцинации против кори, ДКС и гепатита В. В данной группе стран также снижены относительно среднего показатели валового внутреннего продукта и валового национального дохода, уровня санитарных служб и ожидаемой продолжительности жизни, при этом повышен относительно других групп уровень детской смертности и заболеваемость туберкулезом. В кластере же с самыми высокими экономическими показателями мы видим на уровне ниже среднего показатели смертности, долю сельского населения, при этом все остальные показатели в области среднего значения (в этой группе, по-видимому, США и Китай). Также выделена в отдельный кластер группа стран с высоким уровнем суицидов, при этом другие показатели в этой группе не отличаются значительно от средних значений (только незначительно повышена ожидаемая продолжительность жизни).
Проведем анализ главных компонент датасета с нумерическими переменными без переменной Year.
led_c.pca <- prcomp(led_c, scale = T)
fviz_eig(led_c.pca, addlabels = T, ylim = c(0, 45))
74% вариативности данных обьясняются первыми пятью главными компонентами, при этом значительно - только первой.
Посмотрим переменные, по которым строилась первая, вторая и третья главные компоненты:
fviz_contrib(led_c.pca, choice = "var", axes = 1, top = 19) # 1
fviz_contrib(led_c.pca, choice = "var", axes = 2, top = 19) # 2
fviz_contrib(led_c.pca, choice = "var", axes = 3, top = 19) # 3
Видим, что в первую главную компоненту (объясняет 39.9% вариабельности) основной вклад вносят ожидаемая продолжительность жизни, детская смертность, уровень работы санитарных служб, качетво воды и питания. Во вторую главную компоненту (объясняет 11.6% вариабельности) - уровень иммунизации от опасных инфекций, в третью (объясняет 10.2% вариабельности) - экономические показатели: валовый внутренний продукт и валовый национальный доход.
fviz_pca_var(led_c.pca, col.var = "contrib", labelsize = 2)
Видим, что показатели иммунизации очень близки друг к другу, имеет смысл объединить их в одну переменную. Вторая группа показателей - показатели смертности и заболеваемости туберкулезом. Третья группа - показатель качества воды и питания, продолжительности жизни и уровень работы санитарных служб.
Можно выделить 6 переменных, которые вносят наибольший вклад в первые 2 главные компоненты:
fviz_pca_var(led_c.pca,
select.var = list(contrib = 6), # Задаём число здесь
col.var = "contrib")
b <- ggbiplot(led_c.pca,
scale = 0,
groups = as.factor(led$continent),
ellipse = TRUE,
alpha = 0.7,
varname.size = 3,
labels = (led$Country),
labels.size = 2
) +
theme_classic()
ggplotly(b, tooltip = c("xvar", "yvar", "labels", "groups"))
Проанализировав график, можем отметить, что значительные различия показателей отмечаются между африканским и европейским регионами, осталные группы стран на графике смешаны, с центрами элипсов близко к области нуля относительно первых двух главных компонент
umap_prep <- recipe(~., data = led_c) %>%
step_normalize(all_predictors()) %>%
step_umap(all_predictors()) %>%
prep() %>%
juice()
umap_prep %>%
ggplot(aes(UMAP1, UMAP2)) +
geom_point(aes(color = led$continent),
alpha = 0.7, size = 2) +
labs(color = NULL)
Результат анализа UMAP показывает более четкое разделение наблюдений на
группы (UMAP ориентирован на сохранение локального расстояние между
точками в отличае от PCA, ориентированного на сохранение глобальной
структуры данных). Опираясь на полученные результаты, можно
формулировать гипотезы о различиях между данными группами стран, а также
проводить анализ внутри групп.
# 1
set.seed(42)
for (i in 1:3) {
columns_to_remove <- sample(colnames(led_c), 5)
print(paste("Удалены переменные:", paste(columns_to_remove, collapse = ", ")))
led_c_rem <- led_c %>% select(!columns_to_remove)
led_c_rem.pca <- prcomp(led_c_rem, scale = T)
p1 <- fviz_eig(led_c_rem.pca, addlabels = T, ylim = c(0, 45))
print(p1)
p2 <- fviz_pca_var(led_c_rem.pca, col.var = "contrib", labelsize = 2)
print(p2)}
## [1] "Удалены переменные: Rural population, GNI, Life expectancy, Tuberculosis Incidence, DPT Immunization"
## [1] "Удалены переменные: GDP, Non-communicable Mortality, Rural population, Urban population, Tuberculosis treatment"
## [1] "Удалены переменные: Per Capita, GDP, GNI, Basic sanitation services, Non-communicable Mortality"
Значения cumulative proportion не изменились значительно при удалении 5 случайных переменных (но, тем не менее, увеличились). Это связано с тем, что вклад в главные компоненты вносят несколько достаточно вариативных переменных. В том случае, если буду удалены большинство из переменных, определяющих первые 3 главные компоненты, то мы увидим более значительные изменения. В этом плане можно рассмотреть 3 случай, когда были удалены переменные, в основном определявшие третью главную компоненту, при этом процент cumulative proportion снизился незначительно(с 10.2 до 9) за счет большого числа переменных, вносящих незначительный вклад в третью компоненту.
led_c_reg <- led_c %>%
mutate(Is_Africa = ifelse(led$continent == "Africa", 1, 0),
Is_Oceania = ifelse(led$continent == "Oceania", 1, 0)) %>% group_by(Is_Africa) %>% group_by(Is_Oceania)
led_c_reg.pca <- prcomp(led_c_reg, scale = T)
fviz_eig(led_c_reg.pca, addlabels = T, ylim = c(0, 45))
fviz_pca_var(led_c_reg.pca, col.var = "contrib", labelsize = 2)
d <- ggbiplot(led_c_reg.pca,
scale = 0,
groups = led_c_reg$Is_Africa,
ellipse = TRUE,
alpha = 0.7,
varname.size = 3
) +
theme_classic()
ggplotly(d, tooltip = c("xvar", "yvar", "groups"))
d <- ggbiplot(led_c_reg.pca,
scale = 0,
groups = led_c_reg$Is_Oceania,
ellipse = TRUE,
alpha = 0.7,
varname.size = 3
) +
theme_classic()
ggplotly(d, tooltip = c("xvar", "yvar", "groups"))
При сравнении графиков можно отметить, что разброс значений показателей в Океании приблизительно соответствует разбросу переменных для других стран относительно первых двух главных компонент, а в африканском регионе значения показателей относительно главных компонент отличаются от остальных стран. Насколько я понимаю, добавление дамми-колонки не корректно, так как разброс данных в незначительностей степени определяется принадлежностью к региону, что не позволяет формулировать гипотезы в зависимости от принадлежности к региону.